Cream of the Crop 1/Cream of the Crop 1.iso/PROGRAM/ICNDRW_1.ARJ/ICONTOOL.PAS

Pascal/Delphi Source File | 1991-08-20 | 17KB | 729 lines

{=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
                                 ------------
                                  ICON TOOLS
                                 ------------

                  Copyright (c) 1991 - SofDesign Technology
                             All Rights Reserved

        ICON TOOLS is a programmers library for manipulating icons
        created with ICON DRAW 1.0.  With this library you can load
        icons from either .ICN bit mapped files or from .ILB icon
        library files created with the ICONLIB program.  Each icon
        is considered to be an object, hence the fully onject oriented
        nature of this library.  With an ICON object, you can drag,
        move and manipulate the icon in a number of ways.  This
        unit is good for creating a graphically oriented icon-based
        GUI, though it's up to you to do the rest.

 =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=}

{$I-}
{$X+}
{$G+}
{$S-}
{$R-}

unit icontool;

interface

uses mouse,graph,ttools;

const
  titleon : boolean = true;
  titleoff: boolean = false;

type

  icon_record = record
    len,
    height : integer;
    fname  : string[12];
    title  : string[25];
    size   : longint;
  end;

  header_type = record
    version : string[10];
    numicons : word;
  end;

  icon_window = record
    left,
    top,
    bottom,
    right   : integer;
  end;

  {----------------------------------------------------------
        The icon object.  To initialize, you specify
        a library name and an icon name within the
        library.  If no library is indicated, then
        the object searches the directory for the
        icon itself.  If in either case the icon cannot
        be loaded, and error flag is set and can be
        checked with the INITERROR function.
   ----------------------------------------------------------}
  icon = object
    x,y        : integer;
    theicon    : icon_record;
    error      : boolean;
    put_type   : word;
    titleon    : boolean;
    hidden     : boolean;
    libheader  : header_type;
    boundaries : icon_window;

    procedure init(iconlib:string; iconfile:string; startx,starty: integer);
    function  initerror:boolean;
    function  inbounds(mx,my:integer):boolean;
    function  is_hidden:boolean;
    function  is_showing:boolean;
    function  get_length:integer;
    function  get_height:integer;
    function  getx:integer;
    function  gety:integer;
    function  gettop:integer;
    function  getleft:integer;
    function  getbottom:integer;
    function  getright:integer;
    procedure setboundaries(x1,y1,x2,y2:integer);
    procedure showicon;
    procedure hideicon;
    procedure icontitle(on:boolean);
    procedure setput(put:word);
    procedure setxy(newx,newy:integer);
    procedure moveicon(newx,newy:integer);
    procedure mousedragicon(onbutton:word);
    procedure display_icon;
    procedure disposeicon;
    procedure done;
  private
    image_behind : pointer;
    icon_image   : pointer;
    title_image  : pointer;
    size,
    size_title_image : longint;
    procedure get_rear_image;
    procedure get_title_image;
    procedure dispose_rear_image;
    procedure dispose_title_image;
  end;

  icon_manager = object(icon)
    icons : array [1..500] of ^icon;
    numicons : integer;
    ontop : boolean;
    mboundaries : icon_window;

    procedure init(left,top,bottom,right:integer);
    procedure addicon(iconlib:string; iconfile:string; startx,starty: integer; put:word; t:boolean);
    procedure allowontop(on:boolean);
    function  initerror(i:integer):boolean;
    function  inbounds(i:integer; mx,my:integer):boolean;
    function  onanother(i:integer):boolean;
    function  onwhichicon(mx,my:word):integer;
    function  is_hidden(i:integer):boolean;
    function  is_showing(i:integer):boolean;
    function  get_length(i:integer):integer;
    function  get_height(i:integer):integer;
    function  getx(i:integer):integer;
    function  gety(i:integer):integer;
    function  gettop(i:integer):integer;
    function  getleft(i:integer):integer;
    function  getbottom(i:integer):integer;
    function  getright(i:integer):integer;
    function  currenticon:integer;
    function  withinboundaries(mx,my:integer):boolean;
    procedure setmanagerboundaries(x1,y1,x2,y2:integer);
    procedure setboundaries(i,x1,y1,x2,y2:integer);
    procedure showicon(i:integer);
    procedure hideicon(i:integer);
    procedure icontitle(i:integer; on:boolean);
    procedure setput(i:integer; put:word);
    procedure setxy(i:integer; newx,newy:integer);
    procedure moveicon(i:integer; newx,newy:integer);
    procedure mousedragicon(onbutton:word);
    procedure display_icon(i:integer);
    procedure disposeicon(i:integer);
    procedure showallicons;
    procedure hideallicons;
    procedure disposeallicons;
    procedure done;
  end;

var
  amouse : boolean;

implementation

procedure read_lib_header(var f:file; var lh:header_type);
begin
  blockread(f,lh,sizeof(lh));
end;

procedure get_lib_icon(var f:file; lh:header_type; iconame: string; var icon:icon_record; var err:boolean);
var i:integer;
    found : boolean;
    t:icon_record;
    p:pointer;
begin
  i:=0;
  found:=false;
  repeat
    inc(i);
    blockread(f,t,sizeof(t));
    found:=t.fname=iconame;
    if not found then
    begin
      getmem(p,t.size);
      blockread(f,p^,t.size);
      freemem(p,t.size);
    end;
  until (found) or (i=lh.numicons);
  if found then
  begin
    icon:=t;
    err:=false;
  end
  else
    err:=true;
end;

procedure icon.init(iconlib:string; iconfile:string; startx,starty:integer);
var f:file;
begin
  x:=startx;
  y:=starty;
  iconlib:=upstring(iconlib,1);
  iconfile:=upstring(iconfile,1);
  if iconlib='' then
  begin
    assign(f,iconfile);
    reset(f,1);
    if ioresult<>0 then
      error:=true
    else
    begin
      hidden:=true;
      error:=false;
      blockread(f,theicon,sizeof(theicon));
      getmem(icon_image,theicon.size);
      blockread(f,icon_image^,theicon.size);
      close(f);
    end;
  end
  else
  begin
    assign(f,iconlib);
    reset(f,1);
    if ioresult<>0 then
      error:=true
    else
    begin
      read_lib_header(f,libheader);
      get_lib_icon(f,libheader,iconfile,theicon,error);
      if not error then
      begin
        hidden:=true;
        getmem(icon_image,theicon.size);
        blockread(f,icon_image^,theicon.size);
      end;
      close(f);
    end;
  end;
end;

function icon.initerror;
begin
  initerror:=error;
end;

function icon.is_hidden:boolean;
begin
  is_hidden:=hidden;
end;

function icon.is_showing:boolean;
begin
  is_showing:=not hidden;
end;

function icon.get_length:integer;
begin
  get_length:=theicon.len;
end;

function icon.get_height:integer;
begin
  get_height:=theicon.height;
end;

function icon.getx:integer;
begin
  getx:=x;
end;

function icon.gety:integer;
begin
  gety:=y;
end;

function icon.gettop:integer;
begin
   gettop:=gety;
end;

function icon.getleft:integer;
begin
  getleft:=getx;
end;

function icon.getbottom:integer;
begin
  getbottom:=gety+get_height;
end;

function icon.getright:integer;
begin
  getright:=getx+get_length;
end;

function icon.inbounds(mx,my:integer):boolean;
begin
  inbounds:=((mx>=x) and (mx<=x+theicon.len)) and
            ((my>=y) and (my<=y+theicon.height));
end;

procedure icon.get_rear_image;
begin
  size:=imagesize(x,y,x+theicon.len,y+theicon.height);
  getmem(image_behind,size);
  getimage(x,y,x+theicon.len,y+theicon.height,image_behind^);
end;

procedure icon.dispose_rear_image;
begin
  freemem(image_behind,size);
end;

procedure icon.get_title_image;
begin
  size_title_image:=imagesize(x-1,y+theicon.height,x+length(theicon.title)*8,y+theicon.height+10);
  getmem(title_image,size_title_image);
  getimage(x-1,y+theicon.height,x+length(theicon.title)*8,y+theicon.height+10,title_image^);
end;

procedure icon.dispose_title_image;
begin
  freemem(title_image,size_title_image);
end;

procedure icon.setboundaries(x1,y1,x2,y2:integer);
begin
  with boundaries do
  begin
    left:=x1;
    top:=y1;
    right:=x2;
    bottom:=y2;
    {x:=left+1;
    y:=top+1;}
  end;
end;

procedure icon.showicon;
begin
  if (not initerror) and (is_hidden) then
  begin
    hidden:=false;
    get_rear_image;
    display_icon;
    if titleon then
    begin
      get_title_image;
      setfillstyle(solidfill,0);
      setcolor(getmaxcolor);
      bar(x-1,y+theicon.height,x+length(theicon.title)*8,y+theicon.height+10);
      outtextxy(x,y+theicon.height+1,theicon.title);
    end;
  end;
end;

procedure icon.hideicon;
begin
  if (not initerror) and (is_showing) then
  begin
    hidden:=true;
    putimage(x,y,image_behind^,normalput);
    dispose_rear_image;
    if titleon then
    begin
      putimage(x-1,y+theicon.height,title_image^,copyput);
      dispose_title_image;
    end;
  end;
end;

procedure icon.icontitle(on:boolean);
begin
  titleon:=on;
  if (theicon.title='') and (titleon=true) then
    titleon:=false;
end;

procedure icon.setput(put:word);
begin
  put_type:=put;
end;

procedure icon.setxy(newx,newy:integer);
begin
  x:=newx;
  y:=newy;
end;

procedure icon.moveicon(newx,newy:integer);
begin
  if not initerror then
  begin
    hideicon;
    if newx<boundaries.left then
      newx:=boundaries.left;
    if newy<boundaries.top then
      newy:=boundaries.top;
    if newx+get_length>boundaries.right then
      newx:=boundaries.right-(get_length);
    if newy+get_height>boundaries.bottom then
      newy:=boundaries.bottom-(get_height);
    setxy(newx,newy);
    showicon;
  end;
end;

procedure icon.mousedragicon(onbutton:word);
var mx,my,b:word;
    oldx,oldy : word;
begin
  if amouse then
  begin
    oldx:=0;
    oldy:=0;
    getmouse(mx,my,b);
    if b=onbutton then
    begin
      hidemouse;
      setmouse(x,y);
      while b=onbutton do
      begin
        getmouse(mx,my,b);
        if (oldx<>mx) or (oldy<>my) then
        begin
          oldx:=mx;
          oldy:=my;
          moveicon(mx,my);
        end;
      end;
      showmouse;
    end;
  end;
end;

procedure icon.display_icon;
begin
  putimage(x,y,icon_image^,put_type);
end;

procedure icon.disposeicon;
begin
  if not initerror then
  begin
    freemem(icon_image,theicon.size);
    if not hidden then
      dispose_rear_image;
  end;
end;

procedure icon.done;
begin
end;

procedure icon_manager.init(left,top,bottom,right:integer);
begin
  numicons :=0;
  setmanagerboundaries(left,top,bottom,right);
end;

procedure icon_manager.addicon(iconlib:string; iconfile:string; startx,starty:integer; put:word; t:boolean);
begin
  inc(numicons);
  new(icons[numicons]);
  icons[numicons]^.init(iconlib,iconfile,startx,starty);
  if initerror(numicons) then
  begin
    dispose(icons[numicons]);
    dec(numicons);
  end
  else
  begin
    with icons[numicons]^ do
    begin
      setput(put);
      icontitle(t);
      with mboundaries do
        setboundaries(left,top,right,bottom);
    end;
    setxy(numicons,startx,starty);
  end;
end;

function icon_manager.onanother(i:integer):boolean;
var j:integer;
    found : boolean;
begin
  if numicons>0 then
  begin
    found:=false;
    j:=0;
    repeat
      inc(j);
      if j<>i then
        found:=((icons[i]^.getleft>=icons[j]^.getleft) and (icons[i]^.getright<=icons[j]^.getright)) or
               ((icons[i]^.gettop>=icons[j]^.gettop) and (icons[i]^.getbottom<=icons[j]^.getbottom));
    until found or (j=numicons);
    onanother:=found;
  end;
end;

procedure icon_manager.allowontop(on:boolean);
begin
  ontop:=on;
end;

function icon_manager.initerror(i:integer):boolean;
begin
  if numicons>0 then
    initerror:=icons[i]^.initerror;
end;

function icon_manager.is_hidden(i:integer):boolean;
begin
  if numicons>0 then
    is_hidden:=icons[i]^.is_hidden;
end;

function icon_manager.is_showing(i:integer):boolean;
begin
  if numicons>0 then
    is_showing:=icons[i]^.is_showing;
end;

function icon_manager.get_length(i:integer):integer;
begin
  if numicons>0 then
    get_length:=icons[i]^.get_length;
end;

function icon_manager.get_height(i:integer):integer;
begin
  if numicons>0 then
    get_height:=icons[i]^.get_height;
end;

function icon_manager.getx(i:integer):integer;
begin
  if numicons>0 then
    getx:=icons[i]^.getx;
end;

function icon_manager.gety(i:integer):integer;
begin
  if numicons>0 then
    gety:=icons[i]^.gety;
end;

function icon_manager.gettop(i:integer):integer;
begin
  if numicons>0 then
    gettop:=icons[i]^.gettop;
end;

function icon_manager.getleft(i:integer):integer;
begin
  if numicons>0 then
    getleft:=icons[i]^.getleft;
end;

function icon_manager.getbottom(i:integer):integer;
begin
  if numicons>0 then
    getbottom:=icons[i]^.getbottom;
end;

function icon_manager.getright(i:integer):integer;
begin
  if numicons>0 then
    getright:=icons[i]^.getright;
end;

function icon_manager.inbounds(i:integer; mx,my:integer):boolean;
begin
  if numicons>0 then
    inbounds:=icons[i]^.inbounds(mx,my);
end;

function icon_manager.currenticon:integer;
begin
  currenticon:=numicons;
end;

function  icon_manager.withinboundaries(mx,my:integer):boolean;
begin
  with mboundaries do
    withinboundaries:=((mx>=left) and (mx<=right)) and
                      ((my>=top)  and (my<=bottom));
end;

procedure icon_manager.setboundaries(i,x1,y1,x2,y2:integer);
begin
  if numicons>0 then
    icons[i]^.setboundaries(x1,y1,x2,y2);
end;

procedure icon_manager.setmanagerboundaries(x1,y1,x2,y2:integer);
begin
  with mboundaries do
  begin
    top:=y1;
    left:=x1;
    bottom:=y2;
    right:=x2;
  end;
end;

procedure icon_manager.showicon(i:integer);
begin
  if numicons>0 then
    icons[i]^.showicon;
end;

procedure icon_manager.hideicon(i:integer);
begin
  if numicons>0 then
    icons[i]^.hideicon;
end;

procedure icon_manager.icontitle(i:integer; on:boolean);
begin
  if numicons>0 then
    icons[i]^.icontitle(on);
end;

procedure icon_manager.setput(i:integer; put:word);
begin
  if numicons>0 then
    icons[i]^.setput(put);
end;

procedure icon_manager.setxy(i:integer; newx,newy:integer);
begin
  if numicons>0 then
    icons[i]^.setxy(newx,newy);
end;

procedure icon_manager.moveicon(i:integer; newx,newy:integer);
begin
  if numicons>0 then
    icons[i]^.moveicon(newx,newy);
end;

function icon_manager.onwhichicon(mx,my:word):integer;
var found:boolean;
    i:integer;
begin
  i:=0;
  if numicons>0 then
  begin
    found:=false;
    repeat
      inc(i);
      found:=inbounds(i,mx,my);
    until found or (i=numicons);
    if not found then
      i:=0;
  end;
  onwhichicon:=i;
end;

procedure icon_manager.mousedragicon(onbutton:word);
var oldx,oldy,i : integer;
    mx,my,b:word;
begin
  if amouse then
    if numicons>0 then
    begin
      getmouse(mx,my,b);
      i:=onwhichicon(mx,my);
      if i>0 then
      begin
        oldx:=icons[i]^.getx;
        oldy:=icons[i]^.gety;
        icons[i]^.mousedragicon(onbutton);
        if onanother(i) and (not ontop) then
        begin
          hideicon(i);
          setxy(i,oldx,oldy);
          showicon(i);
        end;
      end;
    end;
end;

procedure icon_manager.display_icon(i:integer);
begin
  if numicons>0 then
    icons[i]^.display_icon;
end;

procedure icon_manager.disposeicon(i:integer);
begin
  if numicons>0 then
  begin
    icons[i]^.disposeicon;
    dispose(icons[i]);
  end;
end;

procedure icon_manager.disposeallicons;
var i:integer;
begin
  if numicons>0 then
    for i:=1 to numicons do
      disposeicon(i);
end;

procedure icon_manager.showallicons;
var i:integer;
begin
  if numicons>0 then
    for i:=1 to numicons do
      showicon(i);
end;

procedure icon_manager.hideallicons;
var i:integer;
begin
  if numicons>0 then
    for i:=1 to numicons do
      hideicon(i);
end;

procedure icon_manager.done;
begin
end;

begin
  amouse:=driverinstalled;
end.